home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE11 / FILES / DEBUGU.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-05-31  |  2.2 KB  |  111 lines

  1. unit Debugu;
  2. {$define Debugging}
  3.  
  4. interface
  5.  
  6. uses
  7.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  8.   Forms, Dialogs, StdCtrls, ExtCtrls;
  9.  
  10. {$ifdef Debugging}
  11. type
  12.   TDebugFrm = class(TForm)
  13.     DebugMemo: TMemo;
  14.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  15.   end;
  16.  
  17. var
  18.   DebugFrm: TDebugFrm;
  19. {$endif}
  20.  
  21. procedure AssignDebug(var F: TextFile);
  22.  
  23. implementation
  24.  
  25. {$ifdef Debugging}
  26. {$R *.DFM}
  27. {$endif}
  28.  
  29. function DebugOpen(var F: TTextRec): Integer; far; forward;
  30. function DebugOutput(var F: TTextRec): Integer; far; forward;
  31. function DebugClose(var F: TTextRec): Integer; far; forward;
  32.  
  33. procedure AssignDebug(var F: TextFile);
  34. begin
  35.   { Set up text file variable }
  36.   with TTextRec(F) do
  37.   begin
  38.     Handle := $FFFF;
  39.     OpenFunc := @DebugOpen;
  40.     Mode := fmClosed;
  41.     BufSize := SizeOf(Buffer);
  42.     BufPtr := @Buffer;
  43.     Name[0] := #0;
  44.   end;
  45. end;
  46.  
  47. function DebugOpen(var F: TTextRec): Integer;
  48. begin
  49.   Result := 0;
  50.   with F do
  51.   begin
  52.     if Mode = fmInput then
  53.       { Access denied }
  54.       Result := 5
  55.     else
  56.     begin
  57.       Mode := fmOutput;
  58.       InOutFunc := @DebugOutput;
  59.       FlushFunc := @DebugOutput;
  60.     end;
  61.     CloseFunc := @DebugClose;
  62.   end;
  63. {$ifdef Debugging}
  64.   DebugFrm := TDebugFrm.Create(Application);
  65. {$endif}
  66. end;
  67.  
  68. function DebugOutput(var F: TTextRec): Integer;
  69. var
  70.   Buf: array[0..255] of Char;
  71. begin
  72.   Result := 0;
  73. {$ifdef Debugging}
  74.   { This gets called when a Delphi 2 app shuts, in closing Output }
  75.   { Since it refers to the form which won't exist, don't run it }
  76.   if not Application.Terminated then
  77.   begin
  78.     { If output form ain't showing, show it }
  79.     if not DebugFrm.Visible then
  80.       DebugFrm.Show;
  81.     with F do
  82.     begin
  83.       StrLCopy(Buf, PChar(BufPtr), BufPos);
  84.       DebugFrm.DebugMemo.SelText :=
  85.         StrPas(Buf);
  86.       BufPos := 0;
  87.     end;
  88.   end;
  89. {$endif}
  90. end;
  91.  
  92. function DebugClose(var F: TTextRec): Integer;
  93. begin
  94.   Result := 0;
  95. {$ifdef Debugging}
  96.   DebugFrm.Free;
  97. {$endif}
  98. end;
  99.  
  100. {$ifdef Debugging}
  101. procedure TDebugFrm.FormClose(Sender: TObject; var Action: TCloseAction);
  102. begin
  103.   Action := caNone;
  104. end;
  105. {$endif}
  106.  
  107. initialization
  108.   AssignDebug(Output);
  109.   Rewrite(Output);
  110. end.
  111.